home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / dylan-examples.dyl < prev    next >
Encoding:
Text File  |  1992-11-25  |  30.8 KB  |  1,504 lines  |  [TEXT/gamI]

  1. ;;;; -*- Scheme -*- isn't Thomas (or Dylan(TM))
  2. ;*              Copyright 1992 Digital Equipment Corporation
  3. ;*                         All Rights Reserved
  4. ;*
  5. ;* Permission to use, copy, and modify this software and its documentation is
  6. ;* hereby granted only under the following terms and conditions.  Both the
  7. ;* above copyright notice and this permission notice must appear in all copies
  8. ;* of the software, derivative works or modified versions, and any portions
  9. ;* thereof, and both notices must appear in supporting documentation.
  10. ;*
  11. ;* Users of this software agree to the terms and conditions set forth herein,
  12. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  13. ;* right and license under any changes, enhancements or extensions made to the
  14. ;* core functions of the software, including but not limited to those affording
  15. ;* compatibility with other hardware or software environments, but excluding
  16. ;* applications which incorporate this software.  Users further agree to use
  17. ;* their best efforts to return to Digital any such changes, enhancements or
  18. ;* extensions that they make and inform Digital of noteworthy uses of this
  19. ;* software.  Correspondence should be provided to Digital at:
  20. ;*
  21. ;*                      Director, Cambridge Research Lab
  22. ;*                      Digital Equipment Corp
  23. ;*                      One Kendall Square, Bldg 700
  24. ;*                      Cambridge MA 02139
  25. ;*
  26. ;* This software may be distributed (but not offered for sale or transferred
  27. ;* for compensation) to third parties, provided such third parties agree to
  28. ;* abide by the terms and conditions of this notice.
  29. ;*
  30. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  31. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  32. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  33. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  34. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  35. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  36. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  37. ;* SOFTWARE.
  38.  
  39. ; $Id: dylan-examples.dyl,v 1.16 1992/09/23 04:43:53 birkholz Exp $
  40.  
  41. ;;; This is a copy of examples-from-book.text modified to be runnable in
  42. ;;; the Thomas REP.  The expected return value is given after ";Value: ".
  43. ;;; The book doesn't always show return values, so this value is what you
  44. ;;; can expect from Thomas.  Printed output appears after ";" before
  45. ;;; ";Value: ".  Error messages are quoted from the book.  Thomas doesn't
  46. ;;; report errors in exactly the same way.  Definitions added to make the
  47. ;;; example work are flagged by ";;; +".  Notes about differences from the
  48. ;;; examples as given in the book are prefixed by ";;; ".
  49.  
  50.  
  51. ;; Page 27
  52.  
  53. "abc"
  54. ;Value: "abc"
  55.  
  56. 123
  57. ;Value: 123
  58.  
  59. foo:
  60. ;Value: foo:
  61.  
  62. #\a
  63. ;Value: #\a
  64.  
  65. #t
  66. ;Value: #t
  67.  
  68. #f
  69. ;Value: #f
  70.  
  71. (quote foo)
  72. ;Value: foo
  73.  
  74. 'foo
  75. ;Value: foo
  76.  
  77. '(1 2 3)
  78. ;Value: (1 2 3)
  79.  
  80.  
  81. ;; Page 28
  82.  
  83. ;;; +
  84. (define-class <window> (<object>))
  85. ;Value: <window>
  86.  
  87. <window>
  88. ;Value: #[dylan-class ...]
  89.  
  90. concatenate
  91. ;Value: #[generic function ...]
  92.  
  93. (define my-variable 25)
  94. ;Value: my-variable
  95.  
  96. my-variable
  97. ;Value: 25
  98.  
  99. (bind ((x 50))
  100.   (+ x x))
  101. ;Value: 100
  102.  
  103. (setter element)
  104. ;Value: #[generic function ...]
  105.  
  106. (define (setter my-variable) 20)
  107. ;Value: (setter my-variable)
  108.  
  109. (setter my-variable)
  110. ;Value: 20
  111.  
  112.  
  113. ;; Page 29
  114.  
  115. (+ 3 4)
  116. ;Value: 7
  117.  
  118. (* my-variable 3)
  119. ;Value: 75
  120.  
  121. (* (+ 3 4) 5)
  122. ;Value: 35
  123.  
  124. ((if #t + *) 4 5)
  125. ;Value: 9
  126.  
  127.  
  128. ;; Page 30
  129.  
  130. ; Creates and initializes a module variable
  131. (define my-variable 25)
  132. ;Value: my-variable
  133.  
  134. ; Sets the value to 12
  135. (set! my-variable 12)
  136. ;Value: 12
  137.  
  138. ; Returns 30.  Uses lexical variables x and y.
  139. (bind ((x 10) (y 20))
  140.   (+ x y))
  141. ;Value: 30
  142.  
  143. ; Creates an anonymous method, which expects 2 numeric arguments.
  144. (method ((a <number>) (b <number>))
  145.   (list (- a b) (+ a b)))
  146. ;Value: #[method ..]
  147.  
  148. (values 1 2 3)
  149. ;Value[1]: 1
  150. ;Value[2]: 2
  151. ;Value[3]: 3
  152.  
  153. (define-method edges ((center <number>) (radius <number>))
  154.   (values (- center radius) (+ center radius)))
  155. ;Value: edges
  156.  
  157. (edges 100 2)
  158. ;Value[1]: 98
  159. ;Value[2]: 102
  160.  
  161.  
  162. ;; Page 32
  163.  
  164. foo
  165. ;error: unbound variable foo
  166.  
  167. (define foo 10)
  168. ;Value: foo
  169.  
  170. foo
  171. ;Value: 10
  172.  
  173. (+ foo 100)
  174. ;Value: 110
  175.  
  176. bar
  177. ;error: unbound variable bar
  178.  
  179. (define bar foo)
  180. ;Value: bar
  181.  
  182. bar
  183. ;Value: 10
  184.  
  185. (define foo 20)
  186. ;;; Thomas doesn't warn that module variable foo is being redefined.
  187. ;Value: foo
  188.  
  189. foo
  190. ;Value: 20
  191.  
  192. bar
  193. ;Value: 10
  194.  
  195. (+ foo bar)
  196. ;Value: 30
  197.  
  198.  
  199. ;; Page 33
  200.  
  201. (bind ((number1 20)
  202.        (number2 30))
  203.  (+ number1 number2))
  204. ;Value: 50
  205.  
  206. (bind (age 46
  207.  
  208. (define-method test (the-req !rest the-rest !key a b)
  209.   (print the-req)
  210.   (print the-rest)
  211.   (print a)
  212.   (print b))
  213. ;Value: test
  214.  
  215. (test 1 a: 2 b: 3 c: 4)
  216. ;1
  217. ;(a: 2 b: 3 c: 4)
  218. ;2
  219. ;3
  220. ;No value
  221.  
  222.  
  223. ;; Page 49
  224.  
  225. (define-class <point> (<object>)
  226.   horizontal
  227.   vertical)
  228. ;Value: <point>
  229.  
  230.  
  231. ;; Page 49
  232.  
  233. ;;; +
  234. (define my-point (make <point>))
  235. ;Value: my-point
  236.  
  237. (horizontal my-point)
  238. ;;; The example wasn't intended to demonstrate an uninitialized slot, but
  239. ;;; it's a good thing to test here.
  240. ;error: uninitialized slot
  241.  
  242.  
  243. ;; Page 49
  244.  
  245. ;;; +
  246. (define my-point (make <point>))
  247. ;Value: my-point
  248.  
  249. ((setter horizontal) my-point 10)
  250. ;Value: 10
  251.  
  252. ;;; +
  253. (horizontal my-point)
  254. ;Value: 10
  255.  
  256.  
  257. ;; Page 50
  258.  
  259. ;;; +
  260. (define my-point (make <point>))
  261. ;Value: my-point
  262.  
  263. (set! (horizontal my-point) 10)
  264. ;Value: 10
  265.  
  266. ;;; +
  267. (horizontal my-point)
  268. ;Value: 10
  269.  
  270.  
  271. ;; Page 51
  272.  
  273. ;;; Not materially different from the definition of <point> above.
  274.  
  275.  
  276. ;; Page 55
  277.  
  278. (define-class <rectangle> (<object>)
  279.   (top type: <integer>
  280.        init-value: 0
  281.        init-keyword: top:)
  282.   (left type: <integer>
  283.         init-value: 0
  284.         init-keyword: left:)
  285.   (bottom type: <integer>
  286.           init-value: 100
  287.           init-keyword: bottom:)
  288.   (right type: <integer>
  289.          init-value: 100
  290.          init-keyword: right:))
  291. ;Value: <rectangle>
  292.  
  293. <rectangle>
  294. ;Value: #[dylan-class ...]
  295.  
  296. (define my-rectangle (make <rectangle> top: 50 left: 50))
  297. ;Value: my-rectangle
  298.  
  299. (top my-rectangle)
  300. ;Value: 50
  301.  
  302. (bottom my-rectangle)
  303. ;Value: 100
  304.  
  305. (set! (bottom my-rectangle) 55)
  306. ;Value: 55
  307.  
  308. (bottom my-rectangle)
  309. ;Value: 55
  310.  
  311. (set! (bottom my-rectangle) 'foo)
  312. ;error: foo is not an instance of <integer> while executing (setter bottom).
  313.  
  314.  
  315. ;; Page 58
  316.  
  317. ;;; Punt dots.
  318. (define-class <view> (<object>)
  319.   (position allocation: instance))
  320. ;Value: <view>
  321.  
  322. ;;; Punt dots.
  323. (define-class <displaced-view> (<view>)
  324.   (position allocation: virtual))
  325. ;Value: <displaced-view>
  326.  
  327. (define-method position ((v <displaced-view>))
  328.   (displace-transform (next-method v)))
  329. ;Value: position
  330.  
  331. (define-method (setter position) ((v <displaced-view>)
  332.                                   new-position)
  333.   (next-method v (undisplace-transform new-position)))
  334. ;Value: (setter position)
  335.  
  336. ;;; +
  337. (define-method displace-transform (position)
  338.   (list 'displace-transform position))
  339. ;Value: displace-transform
  340.  
  341. ;;; +
  342. (define-method undisplace-transform (position)
  343.   (list 'undisplace-transform position))
  344. ;Value: undisplace-transform
  345.  
  346. ;;; +
  347. (define my-displaced-view (make <displaced-view> position: 'initial-position))
  348. ;Value: my-displaced-view
  349.  
  350. ;;; +
  351. (position my-displaced-view)
  352. ;Value: (displace-transform initial-position)
  353. ;;; Actually getting (displace-transform ()) instead because of limitation
  354. ;;; (9) in DIFFERENCES.
  355.  
  356. ;;; +
  357. (set! (position my-displaced-view) 'next-position)
  358. ;Value: next-position
  359.  
  360. ;;; +
  361. (position my-displaced-view)
  362. ;Value: (displace-transform (undisplace-transform next-position))
  363.  
  364.  
  365. ;; Page 59
  366.  
  367. ;;; Punt dots.
  368. (define-class <shape> (<view>)
  369.   (image allocation: virtual)
  370.   (cached-image allocation: instance init-value: #f))
  371. ;Value: <shape>
  372.  
  373. (define-method image ((shape <shape>))
  374.   (or (cached-image shape)
  375.       (set! (cached-image shape) (compute-image shape))))
  376. ;Value: image
  377.  
  378. (define-method (setter image) ((shape <shape>) new-image)
  379.   (set! (cached-image shape) new-image))
  380. ;Value: (setter image)
  381.  
  382. ;;; +
  383. (define-method compute-image (shape)
  384.   (list 'compute-image shape))
  385. ;Value: compute-image
  386.  
  387. ;;; +
  388. (define my-shape (make <shape>))
  389. ;Value: my-shape
  390.  
  391. ;;; +
  392. (image my-shape)
  393. ;Value: (compute-image #[dylan-instance ...])
  394.  
  395. ;;; +
  396. ((setter image) my-shape 'new-image)
  397. ;Value: new-image
  398.  
  399. ;;; +
  400. (image my-shape)
  401. ;Value: new-image
  402.  
  403.  
  404. ;; Page 61
  405.  
  406. (define foo 10)
  407. ;;; The book shows 10 being returned, but the definition of define says the
  408. ;;; variable name is returned.
  409. ;Value: foo
  410.  
  411. foo                                     ; this is a variable
  412. ;Value: 10                              ; this is the variable's contents
  413.  
  414. (set! foo (+ 10 10))
  415. ;Value: 20
  416.  
  417. foo
  418. ;Value: 20
  419.  
  420. (setter element)                        ; this is a variable
  421. ;Value: #[generic function ...]         ; the variable's contents
  422.  
  423. ;;; +
  424. ;;; Save the original value to restore for later tests.
  425. (define %original-set-element (setter element))
  426. ;Value: %original-set-element
  427.  
  428. ;;; +
  429. (define-method %set-element (seq index value)
  430.   (print (list '%set-element seq index value))
  431.   value)
  432. ;Value: %set-element
  433.  
  434. (set! (setter element) %set-element)
  435. ;Value: #[generic function ...]
  436.  
  437. (id? (setter element) %set-element)
  438. ;Value: #t
  439.  
  440. ;;; The next two should also work.
  441.  
  442. ;;; +
  443. (set! (element 'foo 'bar) 'baz)
  444. ;(%set-element foo bar baz)
  445. ;Value: baz
  446.  
  447. ;;; +
  448. ((setter element) 'foo 'bar 'baz)
  449. ;(%set-element foo bar baz)
  450. ;Value: baz
  451.  
  452. ;;; +
  453. (set! (setter element) %original-set-element)
  454. ;Value: #[generic function ...]
  455.  
  456.  
  457. ;; Page 62
  458.  
  459. (define foo (vector 'a 'b 'c 'd))
  460. ;Value: foo
  461.  
  462. foo
  463. ;Value: #(a b c d)
  464.  
  465. (element foo 2)
  466. ;Value: c
  467.  
  468. (set! (element foo 2) 'sea)
  469. ;Value: sea
  470.  
  471. (element foo 2)
  472. ;Value: sea
  473.  
  474. foo
  475. ;Value: #(a b sea d)
  476.  
  477.  
  478. ;; Page 64
  479.  
  480. ;;; Renamed test to test2, so this definition doesn't conflict with the
  481. ;;; previous definition of test.
  482. (define-method test2 ((thing <object>))
  483.   (if thing
  484.       #t
  485.       #f))
  486. ;Value: test2
  487.  
  488. (test2 'hello)
  489. ;Value: #t
  490.  
  491. (test2 #t)
  492. ;Value: #t
  493.  
  494. (test2 #f)
  495. ;Value: #f
  496.  
  497. (define-method double-negative ((num <number>))
  498.   (if (< num 0)
  499.       (+ num num)
  500.       num))
  501. ;Value: double-negative
  502.  
  503. (double-negative 11)
  504. ;Value: 11
  505.  
  506. (double-negative -11)
  507. ;Value: -22
  508.  
  509.  
  510. ;; Page 65
  511.  
  512. (define-method show-and-tell ((thing <object>))
  513.   (if thing
  514.       (begin
  515.         (print thing)
  516.         #t)
  517.       #f))
  518. ;Value: show-and-tell
  519.  
  520. (show-and-tell "hello")
  521. ;"hello"
  522. ;Value: #t
  523.  
  524.  
  525. ;; Page 65
  526.  
  527. ;;; +
  528. (define-method bonus-illuminated? (pinball post)
  529.   #t)
  530. ;Value: bonus-illuminated?
  531.  
  532. ;;; +
  533. (define-method add-bonus-score (player delta)
  534.   (list 'add-bonus-score player delta))
  535. ;Value: add-bonus-score
  536.  
  537. ;;; +
  538. (define current-player 'current-player)
  539. ;Value: current-player
  540.  
  541. ;;; +
  542. (define pinball 'pinball)
  543. ;Value: pinball
  544.  
  545. ;;; +
  546. (define post 'post)
  547. ;Value: post
  548.  
  549. (when (bonus-illuminated? pinball post)
  550.   (add-bonus-score current-player 100000))
  551. ;Value: (add-bonus-score current-player 100000)
  552.  
  553.  
  554. ;; Page 65
  555.  
  556. ;;; +
  557. (define-method detect-gas? (nose)
  558.   #f)
  559. ;Value: detect-gas?
  560.  
  561. ;;; +
  562. (define-method light (match)
  563.   (print (list 'strike match))
  564.   (print "KABOOM")
  565.   'oh-well)
  566. ;Value: light
  567.  
  568. ;;; +
  569. (define nose 'nose)
  570. ;Value: nose
  571.  
  572. ;;; +
  573. (define match 'match)
  574. ;Value: match
  575.  
  576. (unless (detect-gas? nose)
  577.         (light match))
  578. ;(strike match)
  579. ;"KABOOM"
  580. ;Value: oh-well
  581.  
  582.  
  583. ;; Page 66
  584.  
  585. ;;; +
  586. (define new-position 100)
  587. ;Value: new-position
  588.  
  589. ;;; +
  590. (define old-position 0)
  591. ;Value: old-position
  592.  
  593. (cond ((< new-position old-position)
  594.        "the new position is less")
  595.       ((= new-position old-position)
  596.        "the positions are equal")
  597.       (else: "the new position is greater"))
  598. ;Value: "the new position is greater"
  599.  
  600.  
  601. ;; Page 67
  602.  
  603. ;;; +
  604. (define-method career-choice (student)
  605.   (cond ((id? student 'paul) 'art)
  606.         ((id? student 'jim) 'history)
  607.         ((id? student 'steve) 'science)
  608.         (else: 'bum)))
  609. ;Value: career-choice
  610.  
  611. ;;; Make this a method for easier testing.
  612. (define babble
  613.   (method (student)
  614.     (case (career-choice student)
  615.       ((art music drama)
  616.        (print "Don't quit your day job."))
  617.       ((literature history linguistics)
  618.        (print "That really is fascinating."))
  619.       ((science math engineering)
  620.        (print "Say, can you fix my VCR?"))
  621.       (else: "I wish you luck."))))
  622. ;Value: babble
  623.  
  624. ;;; +
  625. (babble 'neil)
  626. ;Value: "I wish you luck."
  627.  
  628. ;;; +
  629. (babble 'steve)
  630. ;"Say, can you fix my VCR?"
  631. ;No value
  632.  
  633. ;;; +
  634. (babble 'jim)
  635. ;"That really is fascinating."
  636. ;No value
  637.  
  638. ;;; +
  639. (babble 'paul)
  640. ;"Don't quit your day job."
  641. ;No value
  642.  
  643.  
  644. ;; Page 67
  645.  
  646. ;;; Make this a method for easier testing.
  647. (define whatitis
  648.   (method (my-object)
  649.     (select my-object instance?
  650.       ((<window> <view> <rectangle>) "it's a graphic object")
  651.       ((<number> <list> <sequence>) "it's something computational")
  652.       (else: "Don't know what it is"))))
  653. ;Value: whatitis
  654.  
  655. ;;; +
  656. (whatitis (make <view>))
  657. ;Value: "it's a graphic object"
  658.  
  659. ;;; +
  660. (whatitis #())
  661. ;Value: "it's something computational"
  662.  
  663. ;;; +
  664. (whatitis #f)
  665. ;;; MIT-Scheme does not distinguish #f from (), so this actually looks like
  666. ;;; the end of a list -- "it's something computational".
  667. ;Value: "Don't know what it is"
  668.  
  669.  
  670. ;; Page 68
  671.  
  672. (if #t
  673.     (print "it was true")
  674.     #t
  675.     #f)
  676. ;error: too many arguments to if.
  677.  
  678. (if #t
  679.     (begin
  680.       (print "it was true")
  681.       #t)
  682.     #f)
  683. ;"it was true"
  684. ;Value: #t
  685.  
  686.  
  687. ;; Page 69
  688.  
  689. (define-method factorial ((n <integer>))
  690.   (for ((i n (- i 1))                   ;variable clause 1
  691.         (v 1 (* v i)))                  ;variable clause 2
  692.        ((<= i 0) v)))                   ;end test and result
  693. ;Value: factorial
  694.  
  695.  
  696. ;; Page 69
  697.  
  698. (define-method first-even ((s <sequence>))
  699.   (for-each ((number s))
  700.             ((even? number) number)
  701.                                 ; No body forms needed
  702.     ))
  703. ;Value: first-even
  704.  
  705.  
  706. ;; Page 70
  707.  
  708. ;;; +
  709. (define-method schedule-game ((city <symbol>) (year <number>))
  710.   (print (list year city)))
  711. ;Value: schedule-game
  712.  
  713. (define-method schedule-olympic-games ((cities <sequence>)
  714.                                        (start-year <number>))
  715.   (for-each ((year (range from: start-year by: 4))
  716.              (city cities))
  717.             ()                  ; No end test needed.
  718.     (schedule-game city year)))
  719. ;Value: schedule-olympic-games
  720.  
  721. ;;; +
  722. (schedule-olympic-games
  723.  #(boston new-york baltimore chicago denver san-francisco)
  724.  2000)
  725. ;(2000 boston)
  726. ;(2004 new-york)
  727. ;(2008 baltimore)
  728. ;(2012 chicago)
  729. ;(2016 denver)
  730. ;(2020 san-francisco)
  731. ;No value
  732.  
  733.  
  734. ;; Page 70
  735.  
  736. (begin
  737.   (dotimes (i 6) (print "bang!"))
  738.   (print "click!"))
  739. ;"bang!"
  740. ;"bang!"
  741. ;"bang!"
  742. ;"bang!"
  743. ;"bang!"
  744. ;"bang!"
  745. ;"click!"
  746. ;No value
  747.  
  748.  
  749. ;; Page 71
  750.  
  751. (define-method first-even ((seq <sequence>))
  752.   (bind-exit (exit)
  753.     (do (method (item)
  754.           (when (even? item)
  755.             (exit item)))
  756.         seq)))
  757. ;Value: first-even
  758.  
  759. (first-even '(1 3 5 4 7 9 10))
  760. ;Value: 4
  761.  
  762.  
  763. ;; Page 72
  764.  
  765. +
  766. ;Value: #[method ...]
  767.  
  768. '+
  769. ;Value: +
  770.  
  771. (quote +)
  772. ;Value: +
  773.  
  774. ''+
  775. ;Value: (quote +)
  776.  
  777. (+ 10 10)
  778. ;Value: 20
  779.  
  780. '(+ 10 10)
  781. ;Value: (+ 10 10)
  782.  
  783. (quote (+ 10 10))
  784. ;Value: (+ 10 10)
  785.  
  786.  
  787. ;; Page 73
  788.  
  789. (apply + 1 '(2 3))
  790. ;Value: 6
  791.  
  792. (+ 1 2 3)
  793. ;Value: 6
  794.  
  795. (define math-functions (list + * / -))
  796. ;Value: math-functions
  797.  
  798. math-functions
  799. ;Value: (#[method ...] #[method ...] #[method ...] #[method ...])
  800.  
  801. (first math-functions)
  802. ;Value: #[method ...]
  803.  
  804. (apply (first math-functions) 1 2 '(3 4))
  805. ;Value: 10
  806.  
  807.  
  808. ;; Page 79
  809.  
  810. (method (num1 num2)
  811.   (+ num1 num2))
  812. ;Value: #[method ...]
  813.  
  814.  
  815. ;; Page 80
  816.  
  817. ;;; +
  818. (define-class <person> (<object>)
  819.   (name init-keyword: name:)
  820.   (age init-keyword: age:))
  821. ;Value: <person>
  822.  
  823. ;;; +
  824. (define person-list
  825.   (list (make <person> name: "Paul" age: 15)
  826.         (make <person> name: "Jill" age: 3)
  827.         (make <person> name: "Jack" age: 2)
  828.         (make <person> name: "Peter" age: 12)))
  829. ;Value: person-list
  830.  
  831. ;;; Wrap this in a for-each that shows us the sorted list.
  832. ;;; Put the test: keyword before the test argument.
  833. (for-each
  834.      ((person
  835.        (sort person-list
  836.          test: (method (person1 person2)
  837.                      (< (age person1)
  838.                         (age person2))))))
  839.      ()
  840.   (print (name person)))
  841. ;"Jack"
  842. ;"Jill"
  843. ;"Peter"
  844. ;"Paul"
  845. ;Value: #f
  846.  
  847. (bind ((double (method (number)
  848.                  (+ number number))))
  849.   (double (double 10)))
  850. ;Value: 40
  851.  
  852.  
  853. ;; Page 80
  854.  
  855. (define-method double ((my-method <function>))
  856.   (method (!rest args)
  857.     (apply my-method args)
  858.     (apply my-method args)
  859.     #f))
  860. ;Value: double
  861.  
  862. ;;; Changed print to display.
  863. (define print-twice (double display))
  864. ;Value: print-twice
  865.  
  866. print-twice
  867. ;Value: #[method ...]
  868.  
  869. (print-twice "The rain in Spain. . .")
  870. ;The rain in Spain. . .The rain in Spain. . .
  871. ;Value: #f
  872.  
  873. (print-twice 55)
  874. ;5555
  875. ;Value: #f
  876.  
  877.  
  878. ;; Page 81
  879.  
  880. ;;; Changed length to size.
  881. (define-method root-mean-square ((s <sequence>))
  882.   (bind-methods ((average (numbers)
  883.                    (/ (reduce1 + numbers)
  884.                       (size numbers)))
  885.                  (square (n) (* n n)))
  886.     (sqrt (average (map square s)))))
  887. ;Value: root-mean-square
  888.  
  889. (root-mean-square '(5 6 6 7 4))
  890. ;Value: 5.692099788303083
  891.  
  892.  
  893. ;; Page 81
  894.  
  895. (define-method newtons-sqrt (x)
  896.   (bind-methods ((sqrt1 (guess)
  897.                    (if (close? guess)
  898.                        guess
  899.                        (sqrt1 (improve guess))))
  900.                  (close? (guess)
  901.                    (< (abs (- (* guess guess) x)) .0001))
  902.                  (improve (guess)
  903.                    (/ (+ guess (/ x guess)) 2)))
  904.     (sqrt1 1)))
  905. ;Value: newtons-sqrt
  906.  
  907. (newtons-sqrt 25)
  908. ;Value: 5.000000000053723
  909.  
  910.  
  911. ;; Page 82
  912.  
  913. (define-method double ((thing <number>))
  914.   (+ thing thing))
  915. ;Value: double
  916.  
  917.  
  918. ;; Page 82
  919.  
  920. (double 10)
  921. ;Value: 20
  922.  
  923. (double 4.5)
  924. ;Value: 9.0
  925.  
  926.  
  927. ;; Page 82
  928.  
  929. (define-method double ((thing <integer>))
  930.   (* thing 2))
  931. ;Value: double
  932.  
  933.  
  934. ;; Page 82
  935.  
  936. (define-method double ((thing (singleton 'cup)))
  937.   'pint)
  938. ;Value: double
  939.  
  940. (double 'cup)
  941. ;Value: pint
  942.  
  943.  
  944. ;; Page 83
  945.  
  946. (define-method double ((num <float>))
  947.   (print "doubling a floating-point number")
  948.   (next-method))
  949. ;Value: double
  950.  
  951. (double 10.5)
  952. ;"doubling a floating-point number"
  953. ;Value: 21.0
  954.  
  955.  
  956. ;; Page 85
  957.  
  958. ;;; +
  959. (define-class <file> (<object>)
  960.   name)
  961. ;Value: <file>
  962.  
  963. (define-method show ((device <window>) (thing <character>))
  964.   (print '(show <window> <character>)))
  965. ;Value: show
  966.  
  967. (define-method show ((device <window>) (thing <string>))
  968.   (print '(show <window> <string>)))
  969. ;Value: show
  970.  
  971. (define-method show ((device <window>) (thing <rectangle>))
  972.   (print '(show <window> <rectangle>)))
  973. ;Value: show
  974.  
  975. (define-method show ((device <file>) (thing <character>))
  976.   (print '(show <file> <character>)))
  977. ;Value: show
  978.  
  979. (define-method show ((device <file>) (thing <string>))
  980.   (print '(show <file> <string>)))
  981. ;Value: show
  982.  
  983. ;;; +
  984. (show (make <window>) #\Return)
  985. ;(show <window> <character>)
  986. ;No value
  987.  
  988. ;;; +
  989. (show (make <window>) "Return")
  990. ;(show <window> <string>)
  991. ;No value
  992.  
  993. ;;; +
  994. (show (make <window>) (make <rectangle>))
  995. ;(show <window> <rectangle>)
  996. ;No value
  997.  
  998. ;;; +
  999. (show (make <file>) #\Return)
  1000. ;(show <file> <character>)
  1001. ;No value
  1002.  
  1003. ;;; +
  1004. (show (make <file>) "Return")
  1005. ;(show <file> <string>)
  1006. ;No value
  1007.  
  1008.  
  1009. ;; Page 86
  1010.  
  1011. (make <generic-function> required: 3)
  1012. ;Value: #[generic function ...]
  1013.  
  1014. (make <generic-function> required: 3
  1015.                          debug-name: 'foo)
  1016. ;Value: #[generic function ...]
  1017.  
  1018. (define expand
  1019.   (make <generic-function> required: 1 debug-name: 'expand))
  1020. ;;; The book shows a method being returned, but the definition of define
  1021. ;;; says the variable name is returned.
  1022. ;Value: expand
  1023.  
  1024. (expand 55)
  1025. ;error: no applicable method for 55 in {the generic function expand}
  1026.  
  1027.  
  1028. ;; Page 97
  1029.  
  1030. (define-method double ((thing (singleton 'cup)))
  1031.   'pint)
  1032. ;Value: double
  1033.  
  1034. (double 'cup)
  1035. ;Value: pint
  1036.  
  1037. (double 10)
  1038. ;Value: 20
  1039.  
  1040.  
  1041. ;; Page 98
  1042.  
  1043. (define-method factorial ((num <integer>))
  1044.   (* num (factorial (- num 1))))
  1045. ;Value: factorial
  1046.  
  1047. (define-method factorial ((num (singleton 0)))
  1048.   1)
  1049. ;Value: factorial
  1050.  
  1051. (factorial 5)
  1052. ;Value: 120
  1053.  
  1054.  
  1055. ;; Page 100
  1056.  
  1057. (do (method (a b) (print (+ a b)))
  1058.     '(100 100 200 200)
  1059.     '(1 2 3 4))
  1060. ;101
  1061. ;102
  1062. ;203
  1063. ;204
  1064. ;Value: #f
  1065.  
  1066.  
  1067. ;; Page 101
  1068.  
  1069. (map + '(100 100 200 200)
  1070.        '(1 2 3 4))
  1071. ;Value: (101 102 203 204)
  1072.  
  1073.  
  1074. ;; Page 101
  1075.  
  1076. (map-as <vector> +
  1077.          '(100 100 200 200)
  1078.          '(1 2 3 4))
  1079. ;Value: #(101 102 203 204)
  1080.  
  1081.  
  1082. ;; Page 101
  1083.  
  1084. (define x '(100 100 200 200))
  1085. ;Value: x
  1086.  
  1087. (map-into x + '(1 2 3 4))
  1088. ;Value: (101 102 203 204)
  1089.  
  1090. x
  1091. ;Value: (101 102 203 204)
  1092.  
  1093.  
  1094. ;; Page 102
  1095.  
  1096. (any? > '(1 2 3 4) '(5 4 3 2))
  1097. ;Value: #t
  1098.  
  1099. (any? even? '(1 3 5 7))
  1100. ;Value: #f
  1101.  
  1102.  
  1103. ;; Page 102
  1104.  
  1105. (every? > '(1 2 3 4) '(5 4 3 2))
  1106. ;Value: #f
  1107.  
  1108. (every? odd? '(1 3 5 7))
  1109. ;Value: #t
  1110.  
  1111.  
  1112. ;; Page 102
  1113.  
  1114. (define high-score 10)
  1115. ;Value: high-score
  1116.  
  1117. (reduce max high-score '(3 1 4 1 5 9))
  1118. ;Value: 10
  1119.  
  1120. (reduce max high-score '(3 12 9 8 8 6))
  1121. ;Value: 12
  1122.  
  1123.  
  1124. ;; Page 103
  1125.  
  1126. (reduce1 + '(1 2 3 4 5))
  1127. ;Value: 15
  1128.  
  1129.  
  1130. ;; Page 103
  1131.  
  1132. (define flavors #(chocolate pistachio pumpkin))
  1133. ;Value: flavors
  1134.  
  1135. (member? 'chocolate flavors)
  1136. ;Value: #t
  1137.  
  1138. (member? 'banana flavors)
  1139. ;Value: #f
  1140.  
  1141.  
  1142. ;; Page 103
  1143.  
  1144. ;;; +
  1145. (define-method has-nuts? (flavor)
  1146.   (member? flavor #(pistachio butter-pecan macadamia)))
  1147. ;Value: has-nuts?
  1148.  
  1149. flavors
  1150. ;Value: #(chocolate pistachio pumpkin)
  1151.  
  1152. (find-key flavors has-nuts?)
  1153. ;Value: 1
  1154.  
  1155. (element flavors 1)
  1156. ;Value: pistachio
  1157.  
  1158.  
  1159. ;; Page 104
  1160.  
  1161. (define numbers (list 10 13 16 19))
  1162. ;Value: numbers
  1163.  
  1164. (replace-elements! numbers odd? double)
  1165. ;Value: (10 26 16 38)
  1166.  
  1167.  
  1168. ;; Page 104
  1169.  
  1170. (define x (list 'a 'b 'c 'd 'e 'f))
  1171. ;Value: x
  1172.  
  1173. (fill! x 3 start: 2)
  1174. ;Value: (a b 3 3 3 3)
  1175.  
  1176.  
  1177. ;; Page 105
  1178.  
  1179. (define numbers '(3 4 5))
  1180. ;Value: numbers
  1181.  
  1182. (add numbers 1)
  1183. ;Value: (1 3 4 5)
  1184.  
  1185. numbers
  1186. ;Value: (3 4 5)
  1187.  
  1188.  
  1189. ;; Page 105
  1190.  
  1191. (define numbers (list 3 4 5))
  1192. ;Value: numbers
  1193.  
  1194. (add! numbers 1)
  1195. ;Value: (1 3 4 5)
  1196.  
  1197.  
  1198. ;; Page 105
  1199.  
  1200. (add-new '(3 4 5) 1)
  1201. ;Value: (1 3 4 5)
  1202.  
  1203. (add-new '(3 4 5) 4)
  1204. ;Value: (3 4 5)
  1205.  
  1206.  
  1207. ;; Page 105
  1208.  
  1209. (add-new! (list 3 4 5) 1)
  1210. ;Value: (1 3 4 5)
  1211.  
  1212. (add-new! (list 3 4 5) 4)
  1213. ;Value: (3 4 5)
  1214.  
  1215.  
  1216. ;; Page 106
  1217.  
  1218. (remove '(3 1 4 1 5 9) 1)
  1219. ;Value: (3 4 5 9)
  1220.  
  1221.  
  1222. ;; Page 106
  1223.  
  1224. (remove! (list 3 1 4 1 5 9) 1)
  1225. ;Value: (3 4 5 9)
  1226.  
  1227.  
  1228. ;; Page 106
  1229.  
  1230. (choose even? '(3 1 4 1 5 9))
  1231. ;Value: (4)
  1232.  
  1233.  
  1234. ;; Page 106
  1235.  
  1236. (choose-by even? (range from: 1)
  1237.                  '(a b c d e f g h i))
  1238. ;Value: (b d f h)
  1239.  
  1240.  
  1241. ;; Page 107
  1242.  
  1243. (intersection '(john paul george ringo)
  1244.               '(richard george edward charles john))
  1245. ;Value: (john george)
  1246.  
  1247.  
  1248. ;; Page 107
  1249.  
  1250. (union '(butter flour sugar salt eggs)
  1251.        '(eggs butter mushrooms onions salt))
  1252. ;;; The union may have the elements in a different order.
  1253. ;Value: (salt butter flour sugar eggs mushrooms onions)
  1254.  
  1255.  
  1256. ;; Page 107
  1257.  
  1258. (remove-duplicates '(spam eggs spam sausage spam spam spam))
  1259. ;Value: (spam eggs sausage)
  1260.  
  1261.  
  1262. ;; Page 108
  1263.  
  1264. (remove-duplicates! '(spam eggs spam sausage spam spam))
  1265. ;Value: (spam eggs sausage)
  1266.  
  1267.  
  1268. ;; Page 108
  1269.  
  1270. (define hamlet '(to be or not to be))
  1271. ;Value: hamlet
  1272.  
  1273. (id? hamlet (copy-sequence hamlet))
  1274. ;Value: #f
  1275.  
  1276. (copy-sequence hamlet start: 2 end: 4)
  1277. ;Value: (or not)
  1278.  
  1279.  
  1280. ;; Page 108
  1281.  
  1282. (concatenate-as <string> '(#\n #\o #\n) '(#\f #\a #\t))
  1283. ;Value: "nonfat"
  1284.  
  1285. (concatenate-as <vector> '(0 1 2) '(3 4 5) '(6 7 8))
  1286. ;Value: #(0 1 2 3 4 5 6 7 8)
  1287.  
  1288.  
  1289. ;; Page 108
  1290.  
  1291. (concatenate "low-" "calorie")
  1292. ;Value: "low-calorie"
  1293.  
  1294. (concatenate '(0 1 2) '(3 4 5) '(6 7 8))
  1295. ;Value: (0 1 2 3 4 5 6 7 8)
  1296.  
  1297.  
  1298. ;; Page 109
  1299.  
  1300. (define phrase "I hate oatmeal.")
  1301. ;Value: phrase
  1302.  
  1303. (replace-subsequence! phrase "like" start: 2)
  1304. ;Value: "I like oatmeal."
  1305.  
  1306.  
  1307. ;; Page 109
  1308.  
  1309. (define x '(bim bam boom))
  1310. ;Value: x
  1311.  
  1312. (reverse x)
  1313. ;Value: (boom bam bim)
  1314.  
  1315. x
  1316. ;Value: (bim bam boom)
  1317.  
  1318.  
  1319. ;; Page 109
  1320.  
  1321. (reverse! '(bim bam boom))
  1322. ;Value: (boom bam bim)
  1323.  
  1324.  
  1325. ;; Page 110
  1326.  
  1327. (define numbers '(3 1 4 1 5 9))
  1328. ;Value: numbers
  1329.  
  1330. (sort numbers)
  1331. ;Value: (1 1 3 4 5 9)
  1332.  
  1333. numbers
  1334. ;Value: (3 1 4 1 5 9)
  1335.  
  1336.  
  1337. ;; Page 110
  1338.  
  1339. (sort! '(3 1 4 1 5 9))
  1340. ;Value: (1 1 3 4 5 9)
  1341.  
  1342.  
  1343. ;; Page 110
  1344.  
  1345. (last '(emperor of china))
  1346. ;Value: china
  1347.  
  1348.  
  1349. ;; Page 111
  1350.  
  1351. (subsequence-position "Ralph Waldo Emerson" "Waldo")
  1352. ;Value: 6
  1353.  
  1354.  
  1355. ;; Page 113
  1356.  
  1357. (aref #(7 8 9) 1)
  1358. ;Value: 8
  1359.  
  1360.  
  1361. ;; Page 113
  1362.  
  1363. ;;; +
  1364. (define x #(7 8 9))
  1365. ;Value: x
  1366.  
  1367. ;;; Using "x" rather than "#(7 8 9)"
  1368. (set! (aref x 1) 5)
  1369. ;buggy example.  Should return 5
  1370. ;Value: 5
  1371.  
  1372. ;;; +
  1373. x
  1374. ;Value: #(7 5 9)
  1375.  
  1376. ;;; +
  1377. (define x #(7 8 9))
  1378. ;Value: x
  1379.  
  1380. ;;; Using "x" rather than "#(7 8 9)"
  1381. ((setter aref) x 1 5)
  1382. ;buggy example.  Should return 5
  1383. ;Value: 5
  1384.  
  1385. ;;; +
  1386. x
  1387. ;Value: #(7 5 9)
  1388.  
  1389.  
  1390. ;; Page 113
  1391.  
  1392. (dimensions (make <array> dimensions: '(4 4)))
  1393. ;Value: (4 4)
  1394.  
  1395.  
  1396. ;; Page 115
  1397.  
  1398. (cons 1 2)
  1399. ;Value: (1 . 2)
  1400.  
  1401. (cons 1 '(2 3 4 5))
  1402. ;Value: (1 2 3 4 5)
  1403.  
  1404.  
  1405. ;; Page 115
  1406.  
  1407. (list 1 2 3)
  1408. ;Value: (1 2 3)
  1409.  
  1410. (list (+ 4 3) (- 4 3))
  1411. ;Value: (7 1)
  1412.  
  1413.  
  1414. ;; Page 115
  1415.  
  1416. (list* 1 2 3 '(4 5 6))
  1417. ;Value: (1 2 3 4 5 6)
  1418.  
  1419.  
  1420. ;; Page 116
  1421.  
  1422. (car '(4 5 6))
  1423. ;Value: 4
  1424.  
  1425. (car '())
  1426. ;Value: ()
  1427.  
  1428.  
  1429. ;; Page 116
  1430.  
  1431. (cdr '(4 5 6))
  1432. ;Value: (5 6)
  1433.  
  1434. (cdr '())
  1435. ;Value: ()
  1436.  
  1437.  
  1438. ;; Page 116
  1439.  
  1440. (define x '(4 5 6))
  1441. ;;; The book shows (4 5 6) being returned, but the definition of define
  1442. ;;; says the variable name is returned.
  1443. ;Value: x
  1444.  
  1445. (set! (car x) 9)
  1446. ;Value: 9
  1447.  
  1448. ;;; +
  1449. x
  1450. ;Value: (9 5 6)
  1451.  
  1452.  
  1453. ;; Page 116
  1454.  
  1455. (define x '(4 5 6))
  1456. ;;; The book shows (4 5 6) being returned, but the definition of define
  1457. ;;; says the variable name is returned.
  1458. ;Value: x
  1459.  
  1460. (set! (cdr x) '(a b c))
  1461. ;Value: (a b c)
  1462.  
  1463. ;;; +
  1464. x
  1465. ;Value: (4 a b c)
  1466.  
  1467.  
  1468. ;; Page 120
  1469.  
  1470. (define x "Van Gogh")
  1471. ;Value: x
  1472.  
  1473. (as-lowercase x)
  1474. ;Value: "van gogh"
  1475.  
  1476. ;;; +
  1477. x
  1478. ;Value: "Van Gogh"
  1479.  
  1480.  
  1481. ;; Page 120
  1482.  
  1483. (define x "Van Gogh")
  1484. ;Value: x
  1485.  
  1486. (as-lowercase! x)
  1487. ;Value: "van gogh"
  1488.  
  1489. ;;; +
  1490. x
  1491. ;Value: "van gogh"
  1492.  
  1493.  
  1494. ;; Page 120
  1495.  
  1496. (define x "Van Gogh")
  1497. ;Value: x
  1498.  
  1499. (as-uppercase x)
  1500. ;Value: "VAN GOGH"
  1501.  
  1502. ;;; +
  1503. x
  1504. ;Value